home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpfun.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  18KB  |  482 lines
  1. ;;; CMPFUN  Library functions.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'princ 'c1princ 'c1)
  10. (si:putprop 'princ 'c2princ 'c2)
  11. (si:putprop 'terpri 'c1terpri 'c1)
  12.  
  13. (si:putprop 'apply 'c1apply 'c1)
  14. (si:putprop 'apply 'c2apply 'c2)
  15. (si:putprop 'apply-optimize 'c2apply-optimize 'c2)
  16. (si:putprop 'funcall 'c1funcall 'c1)
  17.  
  18. (si:putprop 'rplaca 'c1rplaca 'c1)
  19. (si:putprop 'rplaca 'c2rplaca 'c2)
  20. (si:putprop 'rplacd 'c1rplacd 'c1)
  21. (si:putprop 'rplacd 'c2rplacd 'c2)
  22.  
  23. (si:putprop 'si::memq 'c1memq 'c1)
  24. (si:putprop 'member 'c1member 'c1)
  25. (si:putprop 'member!2 'c2member!2 'c2)
  26. (si:putprop 'assoc 'c1assoc 'c1)
  27. (si:putprop 'assoc!2 'c2assoc!2 'c2)
  28. (si:putprop 'get 'c1get 'c1)
  29. (si:putprop 'get 'c2get 'c2)
  30.  
  31. (si:putprop 'list '(c1list-condition . c1list) 'c1conditional)
  32. (si:putprop 'list* '(c1list-condition . c1list*) 'c1conditional)
  33. (si:putprop 'nth '(c1nth-condition . c1nth) 'c1conditional)
  34. (si:putprop 'nthcdr '(c1nthcdr-condition . c1nthcdr) 'c1conditional)
  35. (si:putprop 'si:rplaca-nthcdr 'c1rplaca-nthcdr 'c1)
  36. (si:putprop 'rplaca-nthcdr-immediate 'c2rplaca-nthcdr-immediate 'c2)
  37. (si:putprop 'si:list-nth 'c1list-nth 'c1)
  38. (si:putprop 'list-nth-immediate 'c2list-nth-immediate 'c2)
  39.  
  40. (defvar *princ-string-limit* 80)
  41.  
  42. (defun c1princ (args &aux stream (info (make-info)))
  43.   (when (endp args) (too-few-args 'princ 1 0))
  44.   (unless (or (endp (cdr args)) (endp (cddr args)))
  45.           (too-many-args 'princ 2 (length args)))
  46.   (setq stream (if (endp (cdr args))
  47.                    (c1nil)
  48.                    (c1expr* (cadr args) info)))
  49.   (if (and (or (and (stringp (car args))
  50.                     (<= (length (car args)) *princ-string-limit*))
  51.                (characterp (car args)))
  52.            (or (endp (cdr args))
  53.                (and (eq (car stream) 'var)
  54.                     (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL)))))
  55.       (list 'princ info (car args)
  56.             (if (endp (cdr args)) nil (var-loc (caaddr stream)))
  57.             stream)
  58.       (list 'call-global info 'princ
  59.             (list (c1expr* (car args) info) stream))))
  60.  
  61. (defun c2princ (string vv-index stream)
  62.   (cond ((eq *value-to-go* 'trash)
  63.          (cond ((characterp string)
  64.                 (wt-nl "princ_char(" (char-code string))
  65.                 (if (null vv-index) (wt ",Cnil") (wt ",VV[" vv-index "]"))
  66.                 (wt ");"))
  67.                ((= (length string) 1)
  68.                 (wt-nl "princ_char(" (char-code (aref string 0)))
  69.                 (if (null vv-index) (wt ",Cnil") (wt ",VV[" vv-index "]"))
  70.                 (wt ");"))
  71.                (t
  72.                 (wt-nl "princ_str(\"")
  73.                 (dotimes** (n (length string))
  74.                   (let ((char (schar string n)))
  75.                        (cond ((char= char #\\) (wt "\\\\"))
  76.                              ((char= char #\") (wt "\\\""))
  77.                              ((char= char #\Newline) (wt "\\n"))
  78.                              (t (wt char)))))
  79.                 (wt "\",")
  80.                 (if (null vv-index) (wt "Cnil") (wt "VV[" vv-index "]"))
  81.                 (wt ");")))
  82.          (unwind-exit nil))
  83.         ((eql string #\Newline) (c2call-global 'terpri (list stream) nil t))
  84.         (t (c2call-global
  85.             'princ
  86.             (list (list 'LOCATION
  87.                         (make-info :type
  88.                           (if (characterp string) 'character 'string))
  89.                         (list 'VV (add-object string)))
  90.                   stream) nil t))))
  91.  
  92. (defun c1terpri (args &aux stream (info (make-info)))
  93.   (unless (or (endp args) (endp (cdr args)))
  94.           (too-many-args 'terpri 1 (length args)))
  95.   (setq stream (if (endp args)
  96.                    (c1nil)
  97.                    (c1expr* (car args) info)))
  98.   (if (or (endp args)
  99.           (and (eq (car stream) 'var)
  100.                (member (var-kind (caaddr stream)) '(GLOBAL SPECIAL))))
  101.       (list 'princ info #\Newline
  102.             (if (endp args) nil (var-loc (caaddr stream)))
  103.             stream)
  104.       (list 'call-global info 'terpri (list stream))))
  105.  
  106. (defun c1apply (args &aux info)
  107.   (when (or (endp args) (endp (cdr args)))
  108.         (too-few-args 'apply 2 (length args)))
  109.   (let ((funob (c1funob (car args))))
  110.        (setq info (copy-info (cadr funob)))
  111.        (setq args (c1args (cdr args) info))
  112.        (cond ((eq (car funob) 'call-lambda)
  113.               (let* ((lambda-expr (caddr funob))
  114.                      (lambda-list (caddr lambda-expr)))
  115.                     (declare (object lambda-expr lambda-list))
  116.                     (if (and (null (cadr lambda-list))        ; No optional
  117.                              (null (cadddr lambda-list)))    ; No keyword
  118.                         (c1apply-optimize info
  119.                                           (car lambda-list)
  120.                                           (caddr lambda-list)
  121.                                           (car (cddddr lambda-expr))
  122.                                           args)
  123.                        (list 'apply info funob args))))
  124.              (t (list 'apply info funob args))))
  125.   )
  126.  
  127. (defun c2apply (funob args &aux (*vs* *vs*) loc)
  128.   (setq loc (save-funob funob))
  129.   (let ((*vs* *vs*) (base *vs*) (last-arg (list 'CVAR (next-cvar))))
  130.        (do ((l args (cdr l)))
  131.            ((endp (cdr l))
  132.             (wt-nl "{object " last-arg ";")
  133.             (let ((*value-to-go* last-arg)) (c2expr* (car l))))
  134.            (declare (object l))
  135.            (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* (car l))))
  136.        (wt-nl " vs_top=base+" *vs* ";")
  137.        (base-used)
  138.        (cond (*safe-compile*
  139.               (wt-nl " while(!endp(" last-arg "))")
  140.               (wt-nl " {vs_push(car(" last-arg "));")
  141.               (wt last-arg "=cdr(" last-arg ");}"))
  142.              (t
  143.               (wt-nl " while(" last-arg "!=Cnil)")
  144.               (wt-nl " {vs_push((" last-arg ")->c.c_car);")
  145.               (wt last-arg "=(" last-arg ")->c.c_cdr;}")))
  146.        (wt-nl "vs_base=base+" base ";}")
  147.        (base-used))
  148.   (c2funcall funob 'args-pushed loc)
  149.   )
  150.  
  151. (defun c1apply-optimize (info requireds rest body args
  152.                               &aux (vl nil) (fl nil))
  153.   (do ()
  154.       ((or (endp (cdr args)) (endp requireds)))
  155.       (push (pop requireds) vl)
  156.       (push (pop args) fl))
  157.  
  158.   (cond ((cdr args)    ;;; REQUIREDS is NIL.
  159.          (cmpck (null rest)
  160.                 "APPLY passes too many arguments to LAMBDA expression.")
  161.          (push rest vl)
  162.          (push (list 'call-global info 'list* args) fl)
  163.          (list 'let info (reverse vl) (reverse fl) body))
  164.         (requireds    ;;; ARGS is singleton.
  165.          (let ((temp (make-var :kind 'LEXICAL :ref t)))
  166.               (push temp vl)
  167.               (push (car args) fl)
  168.               (list 'let info (reverse vl) (reverse fl)
  169.                     (list 'apply-optimize
  170.                           (cadr body) temp requireds rest body))))
  171.         (rest (push rest vl)
  172.               (push (car args) fl)
  173.               (list 'let info (reverse vl) (reverse fl) body))
  174.         (t
  175.          (let ((temp (make-var :kind 'LEXICAL :ref t)))
  176.               (push temp vl)
  177.               (push (car args) fl)
  178.               (list 'let info (reverse vl) (reverse fl)
  179.                     (list 'apply-optimize
  180.                           (cadr body) temp requireds rest body))))
  181.         )
  182.   )
  183.  
  184. (defun c2apply-optimize (temp requireds rest body
  185.                               &aux (*unwind-exit* *unwind-exit*) (*vs* *vs*)
  186.                                    (*clink* *clink*) (*ccb-vs* *ccb-vs*))
  187.   (when (or *safe-compile* *compiler-check-args*)
  188.         (wt-nl (if rest "ck_larg_at_least" "ck_larg_exactly")
  189.                 "(" (length requireds) ",")
  190.         (wt-var temp nil)
  191.         (wt ");"))
  192.  
  193.   (dolist** (v requireds) (setf (var-ref v) (vs-push)))
  194.   (when rest (setf (var-ref rest) (vs-push)))
  195.  
  196.   (do ((n 0 (1+ n))
  197.        (vl requireds (cdr vl)))
  198.       ((endp vl)
  199.        (when rest
  200.              (wt-nl) (wt-vs (var-ref rest)) (wt "= ")
  201.              (dotimes** (i n) (wt "("))
  202.              (wt-var temp nil)
  203.              (dotimes** (i n) (wt-nl ")->c.c_cdr"))
  204.              (wt ";")))
  205.       (declare (fixnum n) (object vl))
  206.       (wt-nl) (wt-vs (var-ref (car vl))) (wt "=(")
  207.       (dotimes** (i n) (wt "("))
  208.       (wt-var temp nil)
  209.       (dotimes** (i n) (wt-nl ")->c.c_cdr"))
  210.       (wt ")->c.c_car;"))
  211.  
  212.   (dolist** (var requireds) (c2bind var))
  213.   (when rest (c2bind rest))
  214.  
  215.   (c2expr body)
  216.   )
  217.  
  218. (defun c1funcall (args &aux funob (info (make-info)))
  219.   (when (endp args) (too-few-args 'funcall 1 0))
  220.   (setq funob (c1funob (car args)))
  221.   (add-info info (cadr funob))
  222.   (list 'funcall info funob (c1args (cdr args) info))
  223.   )
  224.  
  225. (defun c1rplaca (args &aux (info (make-info)))
  226.   (when (or (endp args) (endp (cdr args)))
  227.         (too-few-args 'rplaca 2 (length args)))
  228.   (unless (endp (cddr args))
  229.           (too-many-args 'rplaca 2 (length args)))
  230.   (setq args (c1args args info))
  231.   (list 'rplaca info args))
  232.  
  233. (defun c2rplaca (args &aux (*vs* *vs*) (*inline-blocks* 0))
  234.   (setq args (inline-args args '(t t)))
  235.   (safe-compile
  236.    (wt-nl "if(type_of(" (car args) ")!=t_cons)"
  237.           "FEwrong_type_argument(Scons," (car args) ");"))
  238.   (wt-nl "(" (car args) ")->c.c_car = " (cadr args) ";")
  239.   (unwind-exit (car args))
  240.   (close-inline-blocks)
  241.   )
  242.  
  243. (defun c1rplacd (args &aux (info (make-info)))
  244.   (when (or (endp args) (endp (cdr args)))
  245.         (too-few-args 'rplacd 2 (length args)))
  246.   (when (not (endp (cddr args)))
  247.         (too-many-args 'rplacd 2 (length args)))
  248.   (setq args (c1args args info))
  249.   (list 'rplacd info args))
  250.  
  251. (defun c2rplacd (args &aux (*vs* *vs*) (*inline-blocks* 0))
  252.   (setq args (inline-args args '(t t)))
  253.   (safe-compile
  254.    (wt-nl "if(type_of(" (car args) ")!=t_cons)"
  255.           "FEwrong_type_argument(Scons," (car args) ");"))
  256.   (wt-nl "(" (car args) ")->c.c_cdr = " (cadr args) ";")
  257.   (unwind-exit (car args))
  258.   (close-inline-blocks)
  259.   )
  260.  
  261. (defun c1memq (args &aux (info (make-info)))
  262.   (when (or (endp args) (endp (cdr args)))
  263.         (too-few-args 'si::memq 2 (length args)))
  264.   (unless (endp (cddr args))
  265.           (too-many-args 'si::memq 2 (length args)))
  266.   (list 'member!2 info 'eq (c1args (list (car args) (cadr args)) info)))
  267.         
  268. (defun c1member (args &aux (info (make-info)))
  269.   (when (or (endp args) (endp (cdr args)))
  270.         (too-few-args 'member 2 (length args)))
  271.   (cond ((endp (cddr args))
  272.          (list 'member!2 info 'eql (c1args args info)))
  273.         ((and (eq (caddr args) :test)
  274.               (or (equal (cdddr args) '((quote eq)))
  275.                   (equal (cdddr args) '((function eq)))))
  276.          (list 'member!2 info 'eq
  277.                (c1args (list (car args) (cadr args)) info)))
  278.         (t
  279.          (list 'call-global info 'member (c1args args info)))))
  280.  
  281. (defun c2member!2 (fun args
  282.                        &aux (*vs* *vs*) (*inline-blocks* 0) (l (next-cvar)))
  283.   (setq args (inline-args args '(t t)))
  284.   (wt-nl "{object x= " (car args) ",V" l "= " (cadr args) ";")
  285.   (if *safe-compile*
  286.       (wt-nl "while(!endp(V" l "))")
  287.       (wt-nl "while(V" l "!=Cnil)"))
  288.   (if (eq fun 'eq)
  289.       (wt-nl "if(x==(V" l "->c.c_car)){")
  290.       (wt-nl "if(eql(x,V" l "->c.c_car)){"))
  291.   (if (and (consp *value-to-go*)
  292.            (or (eq (car *value-to-go*) 'JUMP-TRUE)
  293.                (eq (car *value-to-go*) 'JUMP-FALSE)))
  294.       (unwind-exit t 'JUMP)
  295.       (unwind-exit (list 'CVAR l) 'JUMP))
  296.   (wt-nl "}else V" l "=V" l "->c.c_cdr;")
  297.   (unwind-exit nil)
  298.   (wt "}")
  299.   (close-inline-blocks)
  300.   )
  301.  
  302. (defun c1assoc (args &aux (info (make-info)))
  303.   (when (or (endp args) (endp (cdr args)))
  304.         (too-few-args 'assoc 2 (length args)))
  305.   (cond ((endp (cddr args))
  306.          (list 'assoc!2 info 'eql (c1args args info)))
  307.         ((and (eq (caddr args) ':test)
  308.               (or (equal (cdddr args) '((quote eq)))
  309.                   (equal (cdddr args) '((function eq)))))
  310.          (list 'assoc!2 info 'eq (c1args (list (car args) (cadr args)) info)))
  311.         (t
  312.          (list 'call-global info 'assoc (c1args args info)))))
  313.  
  314. (defun c2assoc!2 (fun args
  315.                       &aux (*vs* *vs*) (*inline-blocks* 0) (al (next-cvar)))
  316.   (setq args (inline-args args '(t t)))
  317.   (wt-nl "{object x= " (car args) ",V" al "= " (cadr args) ";")
  318.   (cond (*safe-compile*
  319.          (wt-nl "while(!endp(V" al "))")
  320.          (if (eq fun 'eq)
  321.              (wt-nl "if(x==car(V" al "->c.c_car)){")
  322.              (wt-nl "if(eql(x,car(V" al "->c.c_car))){")))
  323.         (t
  324.          (wt-nl "while(V" al "!=Cnil)")
  325.          (if (eq fun 'eq)
  326.              (wt-nl "if(x==(V" al "->c.c_car->c.c_car)){")
  327.              (wt-nl "if(eql(x,V" al "->c.c_car->c.c_car)){"))))
  328.   (if (and (consp *value-to-go*)
  329.            (or (eq (car *value-to-go*) 'jump-true)
  330.                (eq (car *value-to-go*) 'jump-false)))
  331.       (unwind-exit t 'jump)
  332.       (unwind-exit (list 'CAR al) 'jump))
  333.   (wt-nl "}else V" al "=V" al "->c.c_cdr;")
  334.   (unwind-exit nil)
  335.   (wt "}")
  336.   (close-inline-blocks)
  337.   )
  338.  
  339. (defun c1get (args &aux (info (make-info)))
  340.   (when (or (endp args) (endp (cdr args)))
  341.         (too-few-args 'get 2 (length args)))
  342.   (when (and (not (endp (cddr args))) (not (endp (cdddr args))))
  343.         (too-many-args 'get 3 (length args)))
  344.   (list 'get info (c1args args info)))
  345.  
  346. (defun c2get (args)
  347.   (if *safe-compile*
  348.       (c2call-global 'get args nil t)
  349.       (let ((*vs* *vs*) (*inline-blocks* 0) (pl (next-cvar)))
  350.            (setq args (inline-args args (if (cddr args) '(t t t) '(t t))))
  351.            (wt-nl "{object V" pl" =(" (car args) ")->s.s_plist;")
  352.            (wt-nl " object ind= " (cadr args) ";")
  353.            (wt-nl "while(V" pl "!=Cnil){")
  354.            (wt-nl "if(V" pl "->c.c_car==ind){")
  355.            (unwind-exit (list 'CADR pl) 'jump)
  356.            (wt-nl "}else V" pl "=V" pl "->c.c_cdr->c.c_cdr;}")
  357.            (unwind-exit (if (cddr args) (caddr args) nil))
  358.            (wt "}")
  359.            (close-inline-blocks)))
  360.   )
  361.  
  362. (defun c1list-condition (args) (declare (ignore args)) (= *space* 0))
  363.  
  364. (defun c1list (args)
  365.   (do ((l (reverse args) (cdr l))
  366.        (form nil))
  367.       ((endp l) (c1expr form))
  368.       (setq form (list 'cons (car l) form))))
  369.  
  370. (defun c1list* (args)
  371.   (when (endp args) (too-few-args 'list* 1 0))
  372.   (setq args (reverse args))
  373.   (do ((l (cdr args) (cdr l))
  374.        (form (car args)))
  375.       ((endp l) (c1expr form))
  376.       (setq form (list 'cons (car l) form))))
  377.  
  378. (defun c1nth-condition (args)
  379.        (and (not (endp args))
  380.             (not (endp (cdr args)))
  381.             (endp (cddr args))
  382.             (numberp (car args))
  383.             (<= 0 (car args) 7)))
  384.  
  385. (defun c1nth (args)
  386.        (c1expr (case (car args)
  387.                      (0 (cons 'car (cdr args)))
  388.                      (1 (cons 'cadr (cdr args)))
  389.                      (2 (cons 'caddr (cdr args)))
  390.                      (3 (cons 'cadddr (cdr args)))
  391.                      (4 (list 'car (cons 'cddddr (cdr args))))
  392.                      (5 (list 'cadr (cons 'cddddr (cdr args))))
  393.                      (6 (list 'caddr (cons 'cddddr (cdr args))))
  394.                      (7 (list 'cadddr (cons 'cddddr (cdr args))))
  395.                      )))
  396.  
  397. (defun c1nthcdr-condition (args)
  398.        (and (not (endp args))
  399.             (not (endp (cdr args)))
  400.             (endp (cddr args))
  401.             (numberp (car args))
  402.             (<= 0 (car args) 7)))
  403.  
  404. (defun c1nthcdr (args)
  405.        (c1expr (case (car args)
  406.                      (0 (cadr args))
  407.                      (1 (cons 'cdr (cdr args)))
  408.                      (2 (cons 'cddr (cdr args)))
  409.                      (3 (cons 'cdddr (cdr args)))
  410.                      (4 (cons 'cddddr (cdr args)))
  411.                      (5 (list 'cdr (cons 'cddddr (cdr args))))
  412.                      (6 (list 'cddr (cons 'cddddr (cdr args))))
  413.                      (7 (list 'cdddr (cons 'cddddr (cdr args))))
  414.                      )))
  415.  
  416. (defun c1rplaca-nthcdr (args &aux (info (make-info)))
  417.   (when (or (endp args) (endp (cdr args)) (endp (cddr args)))
  418.         (too-few-args 'si:rplaca-nthcdr 3 (length args)))
  419.   (unless (endp (cdddr args))
  420.           (too-few-args 'si:rplaca-nthcdr 3 (length args)))
  421.   (if (and (numberp (cadr args)) (<= 0 (cadr args) 10))
  422.       (list 'rplaca-nthcdr-immediate info
  423.             (cadr args)
  424.             (c1args (list (car args) (caddr args)) info))
  425.       (list 'call-global info 'si:rplaca-nthcdr (c1args args info))))
  426.  
  427. (defun c2rplaca-nthcdr-immediate (index args
  428.                                         &aux (*vs* *vs*) (*inline-blocks* 0))
  429.   (setq args (inline-args args '(t t t)))
  430.   (if *safe-compile*
  431.       (progn
  432.        (wt-nl "{object l= ")
  433.        (dotimes** (i index) (wt "cdr("))
  434.        (wt (car args))
  435.        (dotimes** (i index) (wt ")"))
  436.        (wt ";")
  437.        (wt-nl "if(type_of(l)!=t_cons)FEwrong_type_argument(Scons,l);")
  438.        (wt-nl "l->c.c_car= " (cadr args) ";}")
  439.        )
  440.       (progn
  441.        (wt-nl (car args))
  442.        (dotimes** (i index) (wt-nl "->c.c_cdr"))
  443.        (wt-nl "->c.c_car= " (cadr args) ";")))
  444.   (unwind-exit (cadr args))
  445.   (close-inline-blocks)
  446.   )
  447.  
  448. (defun c1list-nth (args &aux (info (make-info)))
  449.   (when (or (endp args) (endp (cdr args)))
  450.         (too-few-args 'si:rplaca-nthcdr 2 (length args)))
  451.   (unless (endp (cddr args))
  452.           (too-few-args 'si:rplaca-nthcdr 2 (length args)))
  453.   (if (and (numberp (car args)) (<= 0 (car args) 10))
  454.       (list 'list-nth-immediate info
  455.             (car args)
  456.             (c1args (list (cadr args)) info))
  457.       (list 'call-global info 'si:list-nth (c1args args info))))
  458.  
  459. (defun c2list-nth-immediate (index args &aux (l (next-cvar))
  460.                                              (*vs* *vs*) (*inline-blocks* 0))
  461.   (setq args (inline-args args '(t t)))
  462.   (wt-nl "{object V" l "= ")
  463.   (if *safe-compile*
  464.       (progn
  465.        (dotimes** (i index) (wt "cdr("))
  466.        (wt (car args))
  467.        (dotimes** (i index) (wt ")"))
  468.        (wt ";")
  469.        (wt-nl "if(type_of(V" l ")!=t_cons)")
  470.        (wt-nl " FEwrong_type_argument(Scons,V" l ");")
  471.        )
  472.       (progn
  473.        (wt-nl (car args))
  474.        (dotimes** (i index) (wt-nl "->c.c_cdr"))
  475.        (wt ";")))
  476.   (unwind-exit (list 'CAR l))
  477.   (wt "}")
  478.   (close-inline-blocks)
  479.   )
  480.  
  481.  
  482.